;;###########################################################################
;; guidemap.lsp
;; Contains code to implement window objects and methods for guidemaps, and 
;; context-sensitive help. Changes for guided applets 7/23/97 fwy
;; Copyright (c) 1992-99 by Forrest W. Young
;;###########################################################################

(defproto guidemap-proto '(slot-info instant-return string) () workmap-proto)

(defmeth guidemap-proto :isnew (&rest args)
  (apply #'call-next-method args)
  (defmeth self :close ()
    (send *vista* :guidemap nil)
    (when (= *color-mode* 0)
          (send self :back-color 'white)
          (send self :back-color 'workmap-background))
    (send self :has-v-scroll (second (send self :size)))
    (call-next-method)))

(defmeth iconmap-proto :slot-info (&optional (list nil set))
  (if set (setf (slot-value 'slot-info) list))
  (slot-value 'slot-info))

(defmeth iconmap-proto :instant-return (&optional (logical nil set))
  (if set (setf (slot-value 'instant-return) logical))
  (slot-value 'instant-return))

(defmeth iconmap-proto :string (&optional (string nil set))
  (if set (setf (slot-value 'string) string))
  (slot-value 'string))

(defmeth guidemap-proto :redraw ()
  (when (send self :gui)
   (let* ((n    (send self :num-icons))
          (icon-list (send self :icon-list))
          (icon-type nil)
          (icon-state nil)
          (redraw-order (send self :redraw-order))
          (draw-x-offset nil)
          (draw-y-offset nil)
          (x    (send self :x))
          (y    (send self :y))
          (draw-color-1 (send self :draw-color))
          (draw-color-2 draw-color-1)
          (back-color (send self :back-color))
          ) 
     (send self :start-buffering)
     (send self :erase-window)
     (when (> n 0)
           (dotimes (i n)
                    (setf icon-type 
                          (send (select icon-list (select redraw-order i)) 
                                :icon-type))
                    (setf icon-state 
                          (send (select icon-list (select redraw-order i)) 
                                :icon-state))
       #+color(when (> *color-mode* 0)
                    (cond 
                      ((= icon-type 6)
                       (if (equal icon-state "grey")
                           (send self :draw-color 'guide-icon-color)
                           (send self :draw-color 'guide-icon-color))
                       (setf draw-color-2 (send self :draw-color))
                       (send self :back-color 'white))
                      ((= icon-type 6)
                       (send self :draw-color 'guide-icon-color)
                       (setf draw-color-2 'guide-icon-color)
                       (send self :back-color 'white))
                      ((= icon-type 7)
                       (send self :draw-color 'black)
                       (setf draw-color-2 'black)
                       (send self :back-color back-color))
                      
                      ))
                      
              (when (select (select (send self :connection-list) 
                                    (select redraw-order i)) 0)
                    (dotimes (j (length (select (send self :connection-list)
                                 (select redraw-order i))))
                     (send self :draw-color 'black)
                     (send self :connect-icons 
                          (select redraw-order i)
                          (select (select (send self :connection-list)
                                 (select redraw-order i)) j))))
                    (send self :draw-color draw-color-2)
                    (when (equal (send (select icon-list 
                                 (select redraw-order i)) :icon-state) "grey")
                    (send self :draw-bitmap 
                          (send (select icon-list (select redraw-order i))
                                :grey-icon)
                          (select x (select redraw-order i)) 
                          (select y (select redraw-order i))))
       
              (when (equal (send (select icon-list 
                           (select redraw-order i)) :icon-state) "normal")
                    (send self :draw-bitmap 
                          (send (select icon-list (select redraw-order i))
                                :icon)
                          (select x (select redraw-order i)) 
                          (select y (select redraw-order i))))
              (when (equal (send (select icon-list 
                           (select redraw-order i)) :icon-state) "selected")
                    (send self :draw-bitmap 
                          (send (select icon-list (select redraw-order i))
                                :icon) ; hi-icon
                          (select x (select redraw-order i)) 
                          (select y (select redraw-order i))))
       #+color(when (> *color-mode* 0)
                    (send self :draw-color draw-color-1))
              (setf draw-x-offset 13)
              (setf draw-y-offset 31)
              (when (or (= 6 icon-type) (= 7 icon-type) (= 2 icon-type))
                    (setf draw-x-offset 23)
                    (setf draw-y-offset 12))
              (send self :draw-text (send 
                        (select icon-list (select redraw-order i)) :title)
                        (+ (select x (select redraw-order i)) draw-x-offset) 
                        (+ (select y (select redraw-order i)) draw-y-offset) 
                    1 1)
                    ))
     (send self :back-color back-color)
     (send self :redraw-overlays)
     (send self :buffer-to-screen)
     )))

(defmeth guidemap-proto :connect-icons (icon-number-out icon-number-in 
                                                       &key new)
  (let* ((icon-out (select (send self :icon-list) icon-number-out))
         (x-out (send icon-out :x))
         (y-out (send icon-out :y))
         (icon-in  (select (send self :icon-list) icon-number-in))
         (x-in  (send icon-in  :x))
         (y-in  (send icon-in  :y))
         (center-out (ceiling (/ (send icon-out :width) 2)))
         (center-in  (ceiling (/ (send icon-in  :width) 2)))
         (below-out  (send icon-out :height))
         (constant   10)
         (text-height (1- (+ (send self :text-descent) (send self :text-ascent))))
         (right-move (- (+ x-in (* 2 center-in) constant) 
                        (+ x-out center-out)))
         (top-move   (- y-in y-out below-out 16))
         (left-move (+ center-in constant))
         )
    (when (> right-move 0) 
          (setf right-move (- x-in constant (+ x-out center-out)))
          (setf left-move (- left-move)))
    (when (<  (+ y-out below-out 15) y-in)
          (setf right-move (- right-move left-move))
          (setf left-move 0))
    (send self :frame-poly 
          (list
           (list (+ x-out center-out) 
                 (+ y-out below-out))
           (list 0 text-height);0 10
           (list right-move 0) 
           (list 0 (- top-move text-height -10));0 top-move
           (list (- left-move)  0)
           '(0 5) '(-3 -3) '(6 0) '(-3 3)) nil)
    (when new 
          (let ((to-list 
                 (select (send self :connection-list) icon-number-out))
                )
            (setf to-list (remove 'nil (combine to-list icon-number-in)))
            (setf (select (send self :connection-list) icon-number-out)
                  to-list)))))

(defmeth guidemap-proto :do-click (x y m1 m2)
  (send help-overlay-proto :do-click x y m1 m2 self)
  (let* ((n (send self :num-icons))
         (redraw-order (send self :redraw-order))
         (i nil)
         (iconx (send self :x))
         (icony (send self :y))
         (icon-type nil)
         (icon-state nil)
         (new-selected-icon nil)
         (newxy nil)
         (ix nil)
         (iy nil)
        )
    (dotimes (j n)
        (setf i  (select redraw-order (- n 1 j)))
        (setf ix (select iconx i))
        (setf iy (select icony i))
        (when (and (> x ix) (< x (+ ix 45)) (> y iy) (< y (+ iy 13)))
           (setf new-selected-icon (select (send self :icon-list) i))
           (setf icon-type (send new-selected-icon :icon-type))
           (setf icon-state (send new-selected-icon :icon-state))
              (when (= icon-type 6) ;guide icon
                    (format t "~s~%" icon-state)
                    (when (not (equal icon-state "grey"))
                      (send self :while-button-down	
                         #'(lambda (x y) 
                             (send new-selected-icon :icon-state "selected"))
                          nil)
                      (send new-selected-icon :icon-state "normal"))
                    (if (< x (+ ix 23))	
                        (send self :show-help   new-selected-icon)
                        (send self :icon-action new-selected-icon)))))))	

(defmeth guidemap-proto :icon-action (icon)
  (when (equal "normal" (send icon :icon-state));selected
        (let* ((to-icon-num-list nil)
               (to-icon nil)
               (icon-list (send self :icon-list))
               (to-icon-type nil)
               (old-selected-icon (send self :selected-icon))
               (result nil))
          (send icon :icon-state "grey")
          (send *vista* :button-down t)
          (unwind-protect 
          (send self :selected-icon (position icon icon-list))
          (setf result (send icon :do-action)) 
(when investigate 
(format t "In ICON-ACTION - working on icon implications.~%")
(check)(break))
          (when (not result) 
                (send icon :icon-state "normal");selected
                (send self :selected-icon old-selected-icon))
          (when result
             (when (and (send *vista* :button-down)
                        (send *vista* :delay-update))
                   (send *guidemap* :toolbar nil))
             (dotimes (i (send self :num-icons))
               (when (equal icon (select icon-list i))
                 (setf to-icon-num-list 
                       (select (send self :connection-list) i))
                 (when (first to-icon-num-list)
                     (dolist (j to-icon-num-list)
                      (setf to-icon-type 
                            (send (select icon-list j) :icon-type))
                      (setf to-icon (select icon-list j))  
(when investigate (format t "Connected Icon ~G~%" j) (break))
                      (cond 
                        ((and (= to-icon-type 7) ;to icon is 'and' icon
                              (equal " " (send to-icon :title))) 
(when investigate (format t "AND Icon~%") (break))
                         (when (= (send to-icon :num-in-connected-now) 0)
                               (send to-icon :num-in-connected-now
                                     (send to-icon :num-in-connections)))
                         (send to-icon :num-in-connected-now
                               (- (send to-icon :num-in-connected-now) 1))
                         (when (= (send to-icon :num-in-connected-now) 0)
                               (dolist 
                                (k (select (send self :connection-list) j))
                                (send (select icon-list k)
                                      :icon-state "normal"))));selected
                        ((and (= to-icon-type 7) ;to icon is 'auto' icon
                              (not (equal " " (send to-icon :title))))
                         (if (and (send *vista* :button-down)
                                  (send *vista* :delay-update))
                             (send *vista* :store-return-info
                                   t (send *vista* :guidemap-number))
                             (send to-icon :do-action)))
                        (t ;to icon is not 'and' icon
                         (send (select icon-list j) :icon-state "normal")))
                        ))))
                (when (and (send *vista* :button-down)
                           (send *vista* :delay-update))
                      (send *guidemap* :toolbar t)
(when investigate 
(format t "In ICON-ACTION, finishing delayed RETRIEVE & UPDATE~%")
(check)(break))
                      (send *guidemap* :retrieve-and-update-guidemap 
                            (- (length (send *vista* :guidemap-slots)) 1))
                      (send self :buffer-to-screen))
                (when (send *vista* :delay-return)
(when investigate 
(format t "In ICON-ACTION, finishing delayed RETURN~%")
(check)(break))
                      (send *guidemap* :return-to-parent-guidemap))
                (send *vista* :delay-update nil)
                (send *vista* :button-down nil)
                (when (send self :instant-return)
                      (send self :return-to-parent-guidemap))
                )))))

;;functions for converting a saved expert workmap file into a novice guidemap
        
;fwy4.28 7/23 modified next function for applets

(defun guidance (&optional string name)
"Args: &OPTIONAL STRING NAME
Function used by guidance menu items and guided applets to show a guidemap. Gives data guidance when STRING is DATA, model guidance when STRING is MODEL, applet guidance when STRING is APPLET, workmap guidance otherwise. NAME is required for APPLETs."
  (let ((object nil)
        ) 
    (if (equal string "applet") 
        (send *vista* :applet-name name)
        (send *vista* :applet-name nil))
    (when (send *vista* :applet-name)
          (send *vista* :applets t) 
          (setf string "applet")
          (setf name (send *vista* :applet-name)))
(when investigate
(format t "Entering GUIDANCE - string: ~a~%" string)
(check)(break))
    (send *vista* :internal-map nil)
    (send *vista* :delay-update nil)
    (when (and (equal string "data") (not current-data)) (setf string nil))
    (when (and (equal string "model") (not current-model)) (setf string nil))
    (cond 
      ((equal string "data")
       (setf object current-data)
       (if (send object :dob-parents)
           (cond 
             ((send object :ways)
              (send *vista* :guidemap-name "save-tab"))
             ((send object :matrices)
              (send *vista* :guidemap-name "save-mat"))
             (t (send *vista* :guidemap-name "save-dat")))
           (cond 
             ((send object :ways)
              (send *vista* :guidemap-name "table-da"))
             ((send object :matrices)
              (send *vista* :guidemap-name "matrix-d"))
             (t (send *vista* :guidemap-name "data-ana")))))
      ((equal string "model")
       (setf object current-model)
       (send *vista* :guidemap-name "model"))
      ((equal string "applet")
       (setf object *workmap*)
       (send *vista* :internal-map t)
       (send *vista* :guidemap-name name))
      (t
       (setf object *workmap*)
       (send *vista* :guidemap-name "load-dat")))
    (when (not object) (setf object *workmap*)) 
(when investigate
(format t "Guidance: system gm= ~g, dob/mob gm = ~g~%object =~a"
(send *vista* :guidemap-number) (send object :guidemap-number) object)
(check)(break))
    (when (not (send object :guidemap-number))
          (send *vista* :need-new-guidemap t)) 
    (let ((guidemap-name (send *vista* :guidemap-name))
          (guidemap-number (send object :guidemap-number)))
      (when (not *guidemap*)
            (setf *guidemap* (guidemap-window))
            (setf *hidden-guidemap* (guidemap-window)))
      (when (send *vista* :need-new-guidemap)
            (send *guidemap* :load-and-store-guidemap guidemap-name)
            (setf guidemap-number 
                  (- (length (send *vista* :guidemap-slots)) 1))
            (send object :guidemap-number guidemap-number))
(when investigate
(format t "In GUIDANCE - entering RETRIEVE & UPDATE:~%") 
(check)(break))
      (when (not (send *vista* :delay-update))
            (send *guidemap* :retrieve-and-update-guidemap guidemap-number))
      (send *guidemap* :toolbar t)
      (when (not (send *vista* :guidemap))
            (send *vista* :guidemap t)
            (send *guidemap* :gui t)))
    (send *vista* :need-new-guidemap nil))
  (send *guidemap* :show-window)
  (send *guidemap* :string string))


(defmeth guidemap-proto :load-and-store-guidemap (guidemap-name)
"Args: guidemap-name
Function to load guidemap file.  The file sends slot information to the hidden guidemap object.  This function then stores the slot information for later use. The hidden guidemap object is used so that the visible guidemap does not change." 
(when investigate
(format t "Load & Store GuideMap ~a~%" guidemap-name))
  (when (send *vista* :button-down) (send *vista* :delay-update t))
  (send *hidden-guidemap* :load-guidemap guidemap-name)
  (send *vista* :store-return-info nil nil)
  (send *vista* :store-slot-info (list (send *hidden-guidemap* :slot-list))))

(defmeth guidemap-proto :retrieve-and-update-guidemap (guidemap-number)
"Args: guidemap-number
Function to retrieve a stored guidemap and update the guidemap window to show the new guidemap."
(when investigate 
(format t "Ready to Retrieve & Update with ~g when system now has ~g~%" 
guidemap-number (send *vista* :guidemap-number))
(check)(break))
  (when (not (eq guidemap-number (send *vista* :guidemap-number)))
        (when investigate
              (format t "Retrieve & Update GuideMap # ~f~%" guidemap-number))
        (send *vista* :guidemap-number guidemap-number)
        (send self :instant-return 
              (select (send *vista* :instant-return) guidemap-number))
        (send self :update-slot-info 
              (select (send *vista* :guidemap-slots) guidemap-number))
        (when (not (send self :instant-return)) (send self :redraw))
        ))

;fwy4.28 7/24/97 modified for applets
(defmeth guidemap-proto :link-to-new-guidemap (string)
"Args: String
Used by Link button to get new guidemap contained in file STRING."
(when investigate 
      (format t "Link-to-new-guidemap: GuideMap Ancestors: ~f~%" 
              (send current-object   :guidemap-ancestors))
      (check)
      (break)
)
  (when current-object 
        (when (not (send current-object :guidemap-number))
              (send current-object :guidemap-number
                    (send *vista* :guidemap-number))))
        
  (send *guidemap* :load-and-store-guidemap
        (blanks-to-dashes (subseq string 0 (min 8 (length string)))))
  (send current-object :guidemap-ancestors
        (append (list (send current-object :guidemap-number))
                (send current-object :guidemap-ancestors) ))
  (send current-object :guidemap-number 
        (- (length (send *vista* :guidemap-slots)) 1))
(when investigate 
      (format t "GuideMap Ancestors: ~f~%"
              (send current-object :guidemap-ancestors))
      (check)
      (break) 
      )
  t)

(provide "guidemap")
